C  THIS PROGRAM CREATES FUNCTIONS FOR THE MUSIC PROGRAM USING 
C  'SEG' OR 'SYNTH'.  UP TO 10 FUNCTIONS CAN BE STORED IN A
C  SINGLE FILE.  ONCE CREATED, THE FUNCTIONS MAY BE CHANGED
C  AND PUT BACK IN THE SAME FILE OR INTO A NEW ONE.
C  NO MORE THAN 50 INPUTS FOR ONE FUNCTION!
C TYPE 'C'(= CRUNCH)  FOR SPECIAL FEATURE SUBR TO COMBINE FUNCS 
C ALREADY MADE.      [MULT, ADD, RETRO, INVRT, ADD CONSTANT ]

C  SEG FUNCS MAY BE 'SMOOTHED' BUT THIS FEATURE AND 'CRUNCH' SHOULD 
C  BE USED SPARINGLY AS ALL 512 WDS OF THE ARRAY MUST BE SAVED.  THIS
C  CLUTTERS UP THE DSK.

C  'C' FOR "ALTER OR FINISH?" WILL JUMP DIRECTLY TO "CRUNCH" MODE.
C    BUT ONCE CHANGED BY 'CRUNCH' THIS UNSTORED ORIG. IS LOST.
C  'SP' (FOR "SEE") WILL PLOT ONE AT A TIME.
C  'SA' PLOTS ALL IN .FUN FILE ON CALCOMP
C  'SX' PLOTS ALL IN XGP FORMAT. (1ST→ <CTRL C>, A DSK PTP  --
C -- WHEN DONE→ <CTRL C>, F )  THEN USE "X" PROG. TYPE 6,11,1.

C FOR EXPONENTIALS GET INTO 'SEG'.  TYPE 'X', DECAY FAC, N.  IF 
C  N IS NON-ZERO THE FUNCTION WILL NOT! NORMALIZE (IE. NOT GO TO 0).
C  THE DECAY FAC. IS THE NUM ALONGTHE SCALE(1-100) WHERE THE CURVE
C  SEEMS TO TOUCH ZERO. (WILL ALWAYS HIT 0 AT END UNLESS N.NE.0.)

C AFTER FILE IS READ IN, <CR> FOR 'TYPE FILE' WILL HOLD ON TO IT.
C  LOAD WITH -- WRIFUN,FUSUB,DFUNC,SSS,MSFAIL.FAI (+RANFIL.MAC?)
	COMMON/S/H,AMP,CON,PH /GRD/ON
	COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
	1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
	COMMON FUNC(512),F2(512),K,I
	DIMENSION RF(4)
21	FORMAT(' A=ALTER, F=FINISH '$)
22	FORMAT(' NEW FUNC, EDIT, CRUNCH, DELETE, RENAME, SEE?   '$)
23	FORMAT(' SEG OR SYNTH?   '$)
25	FORMAT(' TYPE FILE NAME   '$)
26	FORMAT(I3,') TYPE AMPL, STEP# -- OR L=LTPEN   '$)
C  'X' HERE WILL MAKE EXPON. FUNC.
28	FORMAT(' 0=NORM,OR H,A,P,K   '$)
280	FORMAT(' NEW VERSION!  --REPORT ANY PROBLEMS TO LCS'/
	1' UP TO 10 FUNCTIONS MAY BE STORED IN EACH FILE'/
	1' TYPE "B" TO BACKUP AT ANY TIME'//)
30	FORMAT(8F)
31	FORMAT(1XA5,A1,5A5/)
35	FORMAT(1XA5,'IN FILE "',A5,'.FUN"'/)
37	FORMAT(8F9.3)
371	FORMAT(I3,') ',4F8.2)
372	FORMAT(I,21F)
38	FORMAT(2(A5,A1),23A2)
40	FORMAT(11(A1,A3))
41	FORMAT(' ADD TO AN EXISTING FILE?   '$)
42	FORMAT(' WHICH FUNC?   '$)
47	FORMAT(' <CR>=EXIT,   C=CHNG (LN#, CHNGS),'/' I=INSRT,  
	1D=DEL (LN#) '$)
48	FORMAT(' X,N(=DECAY FAC.) FOR XPONTLS')
2281	TYPE 280
281	KZ=0
C   USED IN RELATIVE VECTOR ROUTINE
	Z=0
	XZ=0
	EY=0
	ICUR=0
	XP=0
	KT=0
	FNUM=0
	OLD=0
	FNUM1=0
	TYPE 22
	ACCEPT 40,ON,P
	PLTALL=0
C75	IF(P.EQ.'A'.OR.P.EQ.'X')PLTALL=-1
	IF(P.EQ.'A')GO TO 3280
	IF(P.NE.'X')GO TO 1281
3280	PLTALL=-1
1281	IPLOT=0
	XDPY=-1
	IF(ON.EQ.'N')GO TO 1000
	IF(ON.EQ.'E')GO TO 100
	IF(ON.EQ.'R')GO TO 100
	IF(ON.EQ.'D')GO TO 100
	IF(ON.EQ.'C')GO TO 100
	IF(ON.EQ.'S')GO TO 100
CC 7/74 COLGATE	ON=ONX
C ---OUT 7/74---  RETURNS FOR MORE "SEE"
CC 7/74 COLGATE	GO TO 4281
	GO TO 281
C  WON'T GO ON IF BLANK
C75	IF(ON.EQ.'N'.OR.(ON.EQ.' '.AND.ONX.NE.'S'))GO TO 1000
C75	IF(ON.NE.' ')GO TO 100
C75	ON=ONX
	XDPY=0
C  <CR> FOR 'SEE' WILL DISPLAY UP TO 3 FUNCS AT ONCE.
C  RETURNS FOR MORE "SEE"
C75	GO TO 4281
100	ONX=ON
	TYPE 25
	OLD=-1
	ACCEPT 38,FLNM1
	IF(FLNM1.EQ.' ')FLNM1=FLNM
	IF(FLNM1.EQ.0)GO TO 100
	IF(LOOKF(FLNM1).EQ.0)GO TO 100
	IF(FLNM.NE.FLNM1)GO TO 2151
	OLD=0
4281	TYPE 40,B
	IF(PLTALL)GO TO 5402
	GO TO 1402
2151	FLNM=FLNM1
	CALL READ1
3402	LX=0
	TYPE 40,B
	IF(PLTALL)GO TO 402
C  "SA" WILL PLOT ALL FUNCS IN FILE
	JX=-1
	IF(B(1,2).NE.' ')GO TO 1402
	FNUM1=B(2,1)
C  ONLY ONE FUNC IN FILE.
	GO TO 402
1402	TYPE 42
	ACCEPT 40,BU
	IF(BU.EQ.' ')GO TO 1402
	IF(BU.NE.'B')GO TO 380
	FLNM=0
	JX=0
	GO TO 281
380	REREAD 38,FNUM1
	IDEL=0
C  LX IS MAIN COUNTER
	IF(OLD)GO TO 402
	DO 1302 JX=1,10
1302	IF(FNUM1.EQ.FN(JX))GO TO 5402
C75	GO TO 3402
	GO TO 100
402	CALL READER
	IF(JX)GO TO 100
C 6/74  GO BACK IF IT DIDN'T FIND THE FUNC NAME IN THIS FILE.
C  AT THIS POINT LX=TOTAL FUNCS+1
5402	IF(PLTALL)JX=1
1202	IF(ON.EQ.'C')GO TO 3202
	IF(ON.EQ.'S')GO TO 3202
	IF(ON.NE.'D')GO TO 3281
3202	IF(XDPY)CALL DPYX(1)
	CALL DPYF(JX,FUNC)
	IF(PLTALL)GO TO 2202
	IF(P.EQ.'P')GO TO 2202
	IF(P.EQ.0)GO TO 2202
	IF(ON.EQ.'S')GO TO 2281
	IF(ON.EQ.'C')GO TO 1201
1140	TYPE 1139
	ACCEPT 40,IDEL
	IF(IDEL.EQ.'N')GO TO 2281
	IF(IDEL.NE.'Y')GO TO 1140
	IDEL=JX
	LX=LX-1
C  NOW LX=TOTAL # OF FUNCS.
	CALL WRIFUN
1139	FORMAT(' DELETE IT? ',$)
2202	CALL PLOTIT(FUNC,XA(JX),P)
	IF(P.EQ.'P')GO TO 2281
	JX=JX+1
	FNUM1=B(2,JX)
C75	IF(FNUM1.EQ.' ')GO TO 2281
	IF(FNUM1.EQ.' ')GO TO 4202
	IF(JX.LE.10)GO TO 1202
C  "SA" KEEPS PLOTTING UNTIL NO MORE ARE FOUND
C75	GO TO 2281
4202	CALL DDCLR
	CALL EXIT
3281	X=' '
	TYPE 31,XA(JX),X,FN(JX)
	JT=4
	IF(XA(JX).EQ.'SEG')JT=2
	KZ=1
	DO 137	K=1,50
	KZ=KZ+1
	DO 138 L=1,JT
138	A(K,L)=AA(L,K,JX)
	IF(A(K,1).EQ.999)GO TO 4401
137	IF(A(K,2).GE.100)GO TO 4401

4401	Z=-1
	IF(A(K,2).LE.100)GO TO 4403
	IF(K.GT.1)GO TO 4404
	CALL DPYX(1)
	CALL DPYF(JX,FUNC)
	IF(ON.EQ.'R')GO TO 3032
	TYPE 4405
	A(1,2)=520
	GO TO 4201
4404	TYPE 4402
4403	IF(JT.EQ.2)EY='EG'
	GO TO 1032
4402	FORMAT('  IT WAS SMOOTHED.')
4405	FORMAT(' CANNOT EDIT CRUNCHED FUNCS.'/)
1000	TYPE 23
	ACCEPT 40,BU
	IF(BU.EQ.'B')GO TO 281
	REREAD 40,X,EY
1032	CALL ZERO(FUNC)
C  CLEARS THE FUNC.
	ISMOO=0
	IF(EY.EQ.'EG')GO TO 800
151	EY=0
	JT=4
C  FOR WRIFUN
1031	CALL DPYX(1)
15	KT=1
104	IF(Z.EQ.-1)GO TO 102
	IF(KT.LT.KZ)GO TO 102
	IF(Z.EQ.1)GO TO 2032
1041	KZ=0
	TYPE 28
	Z=0
	ACCEPT 40,BU
	IF(BU.EQ.'B')GO TO 509
	REREAD 30,(A(KT,K),K=1,4)
C ACCEPT HARM,AMPL,PHASE,KONSTANT(IF K>100, MULTIPLIES WAVE *(K-100))
102	H=A(KT,1)
	IF(H.EQ.0)GO TO 2200
	IF(H.EQ.999.)GO TO 2200
C   999 ENDS 'READIN' SYNTHS
	IF(Z.GT.0)TYPE 371,KT,(A(KT,K),K=1,4)
	AMP=A(KT,2)
	PH=A(KT,3)
	CON=A(KT,4)
	CALL SYN(FUNC)
	KT=KT+1
	IF(KZ.LE.KT)CALL DPY(FUNC,1)
	GO TO 104
2201	IF(JT.NE.2)GO TO 1201
	IF(A(KT-1,2).GT.100)GO TO 1201
C  TO USE CURRENT FUNC IN CRUNCH
	IF(LX.GT.10)GO TO 204
	CALL STORE(10)
C  PUTS FROM A ARRAY TO AA ARRAY
	XA(K)='SEG'
	CALL DPYX(1)
	CALL DPYF(10,FUNC)
1201	CALL ZFUNC
C  THIS WILL BE FOR SPECIAL FEATURE PACKAGE
	IF(KT.EQ.512)GO TO 2281
C  FOR BACKUP
4201	EY='EG'
	KT=2
	GO TO 900
 2200	CALL NORM(FUNC)
C   NORMALIZES THE FUNCTION
	CALL DPY(FUNC,1)
 201	IF(BU.EQ.'A')GO TO 2032
	IF(ON.EQ.'R')GO TO 3032
204	TYPE 21
	IF(EY.EQ.'EG')TYPE 271
C   CHANGE IT?
	ACCEPT 40,BU
	IF(BU.EQ.'A')GO TO 210
	IF(BU.EQ.'F')GO TO 900
	IF(BU.EQ.'S')GO TO 7000
	IF(BU.EQ.'C')GO TO 2201
C  TO USE CURRENT FUNC IN CRUNCH
	IF(BU.NE.'B')GO TO 2032
	IF(EY.EQ.'EG')GO TO 509
	GO TO 5091
C   NEXT IS FOR CHANGES ('A' OR <CR>)
2032	TYPE 47
	ACCEPT 40,K
	REREAD 372,L,X,RF
	IF(X.NE.0)GO TO 211
	IF(RF(1).NE.0)GO TO 211
	IF(EY.EQ.'EG')GO TO 204
	BU=0
	GO TO 1041
211	L=X
	IF(K.EQ.'I')GO TO 212
	IF(K.NE.'D')GO TO 205
C   JUMP IF NO DELETE
	KT=KT-1
	DO 209 K=L,KT
	DO 209 J=1,4
209	A(K,J)=A(K+1,J)
	GO TO 210
205	X=RF(2)
	IF(EY.NE.'EG')GO TO 1207
	IF(X.NE.0)GO TO 1205
	X=A(L,2)
	RF(2)=X
C TYPE JUST AMPL. TO CHANGE IT ONLY. (STEP 0 =SAME STEP AS BEFORE.)
1205	IF(X.LT.A(L+1,2))GO TO 208
	IF(L.LT.KT-1)GO TO 2032
	GO TO 208
CXXX212	L=1
CXXX	H=X
CXXX	IF(EY.NE.'EG')GO TO 4212
CXXX	L=L+1
CXXX	H=RF(1)
CXXX4212	DO 1212 K=1,KT
CXXX1212	IF(H.GE.A(K,L))GO TO 2212
C NOW WE KNOW WHERE TO MAKE THE INSERT
CXXX2212	DO 3212 L=4,2,-1
212	DO 3212 L=4,2,-1
3212	RF(L)=RF(L-1)
CC212	IF(RF(2).NE.0)GO TO 213
CXXX	RF(2)=RF(1)
	RF(1)=X
	L=KT
213	IF(EY.NE.'EG')GO TO 214
	X=RF(2)
	DO 215 K=1,KT
	Y=A(K,2)
	IF(X.GT.Y)GO TO 215
C   JUMP IF NOT PAST STEP NUM.
	L=K
	IF(X.EQ.Y)GO TO 208
C   IF STEP=ANOTHER STEP, IT WORKS LIKE 'C'HANGE.
	GO TO 214
215	CONTINUE
214	KT=KT+1
	DO 206 K=KT,L,-1
	DO 206 J=1,4
206	A(K,J)=A(K-1,J)
	GO TO 207
C   TO TYPE OLD NUMBERS
208	IF(X.GT.A(L-1,2))GO TO 1207
	IF(L.GT.1)GO TO 2032
1207	TYPE 371,L,(A(L,K),K=1,4)
207	DO 202 K=1,4
202	A(L,K)=RF(K)
210	KZ=KT
	Z=1
	GO TO 1032
271	FORMAT('+S=SMOOTH  '$)
C  FOR RENAMES
3032	Z=-1
	GO TO 901
900	TYPE 41
C  ADD TO EXISTING FILE
	ISKP=0
	ACCEPT 40,Z
9000	IF(Z.EQ.'B')GO TO 204
	IF(Z.EQ.'Y')GO TO 9001
	IF(Z.NE.'N')GO TO 900
9001	TYPE 25
	ACCEPT 38,FLNM
	IF(FLNM.NE.' ')GO TO 9002
	IF(FLNM1.NE.' ')FLNM=FLNM1
9002	IF(FLNM.EQ.'B')GO TO 204
	IF(FLNM.EQ.' ')GO TO 204
CC	IF(LOOKF(FLNM).AND.Z.EQ.'N')GO TO 902
	IF(LOOKF(FLNM))GO TO 902
	IF(Z.NE.'N')GO TO 900
C  LOOKF CHECKS ON LOOK-UP  FOR NAME.FUN
901	JT=4
	IF(EY.EQ.'EG')JT=2
	IDEL=0
	CALL WRIFUN
	GO TO 900
C  COMES BACK IF NO ROOM IN FILE FOR NEW FUNC.
902	IF(Z.NE.'N')GO TO 901
	TYPE 381,FLNM
	ACCEPT 40,Z
C75	IF(Z.NE.'N')GO TO 901
C75	GO TO 9000
C75 381	FORMAT(' WRITE OVER ',A5,'.FUN?  ',$)
	IF(Z.EQ.'Y')GO TO 903
	GO TO 9000
903	Z='N'
	GO TO 901
C  7/74 COLGATE  NOW WILL REALLY WRITE OVER A FILE!
381	FORMAT(/9X'WRITE OVER ',A5,'.FUN?  ',$)

161	DO 261 K=1,512
261	FUNC(K)=EXP((1-K)/STEP)
	KT=2
	XP=-1
	IF(H.NE.0)GO TO 7009
C  H≠0 = NO NORMALIZATION OF XPONTL
	X=FUNC(512)
	DO 361 K=1,512
361	FUNC(K)=FUNC(K)-(K-1)/511.*X
	GO TO 7009
800	IF(XP)GO TO 510
	X=0
	JT=2
C  JT AND EY SEEM TO PERFORM THE SAME FUNCTIONS??
	Y=0
	KT=1
	N=-256
	CALL DPYX(2)
	CALL DPYBRT(5)
504	IF(KT.GE.KZ)GO TO 510
	AMP=A(KT,1)
5008	STEP=A(KT,2)
	IF(STEP.GT.A(KT-1,2))GO TO 5071
	IF(KT.GT.1)GO TO 509
C   SO IT CAN'T GO BACKWARDS
	GO TO 5071
434	ICUR=0
	CALL CLRCUR
	GO TO 510
C   EXIT FROM CURSOR
CC431	CALL SETCUR(-256,128,0)
431	NX=-256
	NY=128
	NZ=0
C  TYPE <CR> HERE TO SET FIRST POINT AT 0,0
	ICUR=-1
433	CALL SETCUR(NX,NY,NZ)
	NZ=1
C  =1 TO DRAG ALONG VECTOR
	TYPE 432,KT
	ACCEPT 40,AB
	IF(AB.EQ.'B')GO TO 509
	IF(AB.EQ.'R')GO TO 434
	MX=NX
	MY=NY
	CALL RDCUR(NX,NY)
CC	CALL SETCUR(NX,NY,1)
	STEP=(NX+256)/5.12
	AMP=(NY-128)/256.
	IF(KT.EQ.1)STEP=1.
	IF(STEP.LT.100)GO TO 5571
	AMP=((STEP-100)/(STEP-A(KT-1,2)))*(A(KT-1,1)-AMP)+AMP
	ICUR=0
	CALL CLRCUR
	STEP=100.
5571	TYPE 37,AMP,STEP
	GO TO 5071
611	FORMAT(' NO MORE THAN 50 SEGS'/)
610	TYPE 611
509	KT=KT-1
CC	IF(ICUR)CALL SETCUR(MX,MY,1)
5091	IF(KT.LT.1)GO TO 281
	GO TO 210
432	FORMAT(I3,') <CR>=SEG, B=BACKUP, R=RETURN  '/)
510	IF(ICUR)GO TO 433
	IF(KT.EQ.1)TYPE 48
	TYPE 26,KT
	KZ=0
	ACCEPT 40,BU
	IF(BU.EQ.'B')GO TO 509
	IF(BU.EQ.'L')GO TO 431
61	REREAD 30,AMP,STEP,H
	IF(STEP.LT.1)STEP=1
	IF(BU.EQ.'X')GO TO 161
C  TYPE 'X' FOR EXPON. FUNC. + DECAY FACTOR, +1 = NO NORM.
C  WE START WITH STEP 1 (NOT 0)
5071	IF(KT.GT.50)GO TO 610
C   TOO MANY SEGS
	IF(Z.GT.0)TYPE 371,KT,AMP,STEP
	IF(STEP.GT.100)STEP=100
	DIF=AMP-Y
	IF(STEP-X.GT.0)GO TO 9003
	IF(KT.NE.1)GO TO 504
C   SO IT CAN'T BACKUP HERE
9003	IF(STEP.LE.1.)Y=AMP
203	YSTP=STEP
	IF(YSTP.GT.1)GO TO 1203
	YSTP=0
	X=-1
1203	JJX=X*5.120-252
	NX=YSTP*5.120-252
	NY=AMP*256.+128.
	IZ=Y*256.+128.
	CALL ALINE(JJX,IZ,NX,NY)
	CALL DPYOUT(1)
12	Y=AMP
	X=YSTP
	IF(KT.GT.1)GO TO 404
	IF(STEP.LE.1)GO TO 404
C  PUTS 0,0 IN IF 1ST STEP IS NOT 1 OR 0
	A(1,1)=0
	A(1,2)=0
	KT=2
404	A(KT,1)=Y
CC	A(KT,2)=X
	A(KT,2)=STEP
7001	KT=KT+1
C   KT COUNTS SEGMENTS
	IF(STEP.LT.100)GO TO 504
	GO TO 201

7000	IF(ISMOO)GO TO 201
	IF(KT.LE.20)GO TO 7007
	TYPE 7008
	GO TO 509
7008	FORMAT(' NO MORE THAN 20 SEGS IN CURVES'/)
7007	CALL SSS(A,KT-1,FUNC)
C   DRAWS GRID 2
 7009	CALL DPY(FUNC,2)
	A(KT-1,2)=520
	ISMOO=-1
C  SO YOU CAN'T COME BACK 2 TIMES
	GO TO 201
	END